home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / IO / Pty.pm next >
Encoding:
Perl POD Document  |  2010-02-05  |  8.3 KB  |  322 lines

  1. # Documentation at the __END__
  2.  
  3. package IO::Pty;
  4.  
  5. use strict;
  6. use Carp;
  7. use IO::Tty qw(TIOCSCTTY TCSETCTTY TIOCNOTTY);
  8. use IO::File;
  9. require POSIX;
  10.  
  11. use vars qw(@ISA $VERSION);
  12.  
  13. $VERSION = 1.08; # keep same as in Tty.pm
  14.  
  15. @ISA = qw(IO::Handle);
  16. eval { local $^W = 0; undef local $SIG{__DIE__}; require IO::Stty };
  17. push @ISA, "IO::Stty" if (not $@);  # if IO::Stty is installed
  18.  
  19. sub new {
  20.   my ($class) = $_[0] || "IO::Pty";
  21.   $class = ref($class) if ref($class);
  22.   @_ <= 1 or croak 'usage: new $class';
  23.  
  24.   my ($ptyfd, $ttyfd, $ttyname) = pty_allocate();
  25.  
  26.   croak "Cannot open a pty" if not defined $ptyfd;
  27.  
  28.   my $pty = $class->SUPER::new_from_fd($ptyfd, "r+");
  29.   croak "Cannot create a new $class from fd $ptyfd: $!" if not $pty;
  30.   $pty->autoflush(1);
  31.   bless $pty => $class;
  32.  
  33.   my $slave = IO::Tty->new_from_fd($ttyfd, "r+");
  34.   croak "Cannot create a new IO::Tty from fd $ttyfd: $!" if not $slave;
  35.   $slave->autoflush(1);
  36.  
  37.   ${*$pty}{'io_pty_slave'} = $slave;
  38.   ${*$pty}{'io_pty_ttyname'} = $ttyname;
  39.   ${*$slave}{'io_tty_ttyname'} = $ttyname;
  40.  
  41.   return $pty;
  42. }
  43.  
  44. sub ttyname {
  45.   @_ == 1 or croak 'usage: $pty->ttyname();';
  46.   my $pty = shift;
  47.   ${*$pty}{'io_pty_ttyname'};
  48. }
  49.  
  50.  
  51. sub close_slave {
  52.   @_ == 1 or croak 'usage: $pty->close_slave();';
  53.  
  54.   my $master = shift;
  55.  
  56.   if (exists ${*$master}{'io_pty_slave'}) {
  57.     close ${*$master}{'io_pty_slave'};
  58.     delete ${*$master}{'io_pty_slave'};
  59.   }
  60. }
  61.  
  62. sub slave {
  63.   @_ == 1 or croak 'usage: $pty->slave();';
  64.  
  65.   my $master = shift;
  66.  
  67.   if (exists ${*$master}{'io_pty_slave'}) {
  68.     return ${*$master}{'io_pty_slave'};
  69.   }
  70.  
  71.   my $tty = ${*$master}{'io_pty_ttyname'};
  72.  
  73.   my $slave = new IO::Tty;
  74.  
  75.   $slave->open($tty, O_RDWR | O_NOCTTY) ||
  76.     croak "Cannot open slave $tty: $!";
  77.  
  78.   return $slave;
  79. }
  80.  
  81. sub make_slave_controlling_terminal {
  82.   @_ == 1 or croak 'usage: $pty->make_slave_controlling_terminal();';
  83.  
  84.   my $self = shift;
  85.   local(*DEVTTY);
  86.  
  87.   # loose controlling terminal explicitely
  88.   if (defined TIOCNOTTY) {
  89.     if (open (\*DEVTTY, "/dev/tty")) {
  90.       ioctl( \*DEVTTY, TIOCNOTTY, 0 );
  91.       close \*DEVTTY;
  92.     }
  93.   }
  94.  
  95.   # Create a new 'session', lose controlling terminal.
  96.   if (not POSIX::setsid()) {
  97.     warn "setsid() failed, strange behavior may result: $!\r\n" if $^W;
  98.   }
  99.  
  100.   if (open(\*DEVTTY, "/dev/tty")) {
  101.     warn "Could not disconnect from controlling terminal?!\n" if $^W;
  102.     close \*DEVTTY;
  103.   }
  104.  
  105.   # now open slave, this should set it as controlling tty on some systems
  106.   my $ttyname = ${*$self}{'io_pty_ttyname'};
  107.   my $slv = new IO::Tty;
  108.   $slv->open($ttyname, O_RDWR)
  109.     or croak "Cannot open slave $ttyname: $!";
  110.  
  111.   if (not exists ${*$self}{'io_pty_slave'}) {
  112.     ${*$self}{'io_pty_slave'} = $slv;
  113.   } else {
  114.     $slv->close;
  115.   }
  116.  
  117.   # Acquire a controlling terminal if this doesn't happen automatically
  118.   if (defined TIOCSCTTY) {
  119.     if (not defined ioctl( ${*$self}{'io_pty_slave'}, TIOCSCTTY, 0 )) {
  120.       warn "warning: TIOCSCTTY failed, slave might not be set as controlling terminal: $!" if $^W;
  121.     }
  122.   } elsif (defined TCSETCTTY) {
  123.     if (not defined ioctl( ${*$self}{'io_pty_slave'}, TCSETCTTY, 0 )) {
  124.       warn "warning: TCSETCTTY failed, slave might not be set as controlling terminal: $!" if $^W;
  125.     }
  126.   }
  127.  
  128.   if (not open(\*DEVTTY, "/dev/tty")) {
  129.     warn "Error: could not connect pty as controlling terminal!\n";
  130.     return undef;
  131.   } else {
  132.     close \*DEVTTY;
  133.   }
  134.   
  135.   return 1;
  136. }
  137.  
  138. *clone_winsize_from = \&IO::Tty::clone_winsize_from;
  139. *set_raw = \&IO::Tty::set_raw;
  140.  
  141. 1;
  142.  
  143. __END__
  144.  
  145. =head1 NAME
  146.  
  147. IO::Pty - Pseudo TTY object class
  148.  
  149. =head1 VERSION
  150.  
  151. 1.08
  152.  
  153. =head1 SYNOPSIS
  154.  
  155.     use IO::Pty;
  156.  
  157.     $pty = new IO::Pty;
  158.  
  159.     $slave  = $pty->slave;
  160.  
  161.     foreach $val (1..10) {
  162.     print $pty "$val\n";
  163.     $_ = <$slave>;
  164.     print "$_";
  165.     }
  166.  
  167.     close($slave);
  168.  
  169.  
  170. =head1 DESCRIPTION
  171.  
  172. C<IO::Pty> provides an interface to allow the creation of a pseudo tty.
  173.  
  174. C<IO::Pty> inherits from C<IO::Handle> and so provide all the methods
  175. defined by the C<IO::Handle> package.
  176.  
  177. Please note that pty creation is very system-dependend.  If you have
  178. problems, see L<IO::Tty> for help.
  179.  
  180.  
  181. =head1 CONSTRUCTOR
  182.  
  183. =over 3
  184.  
  185. =item new
  186.  
  187. The C<new> constructor takes no arguments and returns a new file
  188. object which is the master side of the pseudo tty.
  189.  
  190. =back
  191.  
  192. =head1 METHODS
  193.  
  194. =over 4
  195.  
  196. =item ttyname()
  197.  
  198. Returns the name of the slave pseudo tty. On UNIX machines this will
  199. be the pathname of the device.  Use this name for informational
  200. purpose only, to get a slave filehandle, use slave().
  201.  
  202. =item slave()
  203.  
  204. The C<slave> method will return the slave filehandle of the given
  205. master pty, opening it anew if necessary.  If IO::Stty is installed,
  206. you can then call C<$slave-E<gt>stty()> to modify the terminal settings.
  207.  
  208. =item close_slave()
  209.  
  210. The slave filehandle will be closed and destroyed.  This is necessary
  211. in the parent after forking to get rid of the open filehandle,
  212. otherwise the parent will not notice if the child exits.  Subsequent
  213. calls of C<slave()> will return a newly opened slave filehandle.
  214.  
  215. =item make_slave_controlling_terminal()
  216.  
  217. This will set the slave filehandle as the controlling terminal of the
  218. current process, which will become a session leader, so this should
  219. only be called by a child process after a fork(), e.g. in the callback
  220. to C<sync_exec()> (see L<Proc::SyncExec>).  See the C<try> script
  221. (also C<test.pl>) for an example how to correctly spawn a subprocess.
  222.  
  223. =item set_raw()
  224.  
  225. Will set the pty to raw.  Note that this is a one-way operation, you
  226. need IO::Stty to set the terminal settings to anything else.
  227.  
  228. On some systems, the master pty is not a tty.  This method checks for
  229. that and returns success anyway on such systems.  Note that this
  230. method must be called on the slave, and probably should be called on
  231. the master, just to be sure, i.e.
  232.  
  233.   $pty->slave->set_raw();
  234.   $pty->set_raw();
  235.  
  236.  
  237. =item clone_winsize_from(\*FH)
  238.  
  239. Gets the terminal size from filehandle FH (which must be a terminal)
  240. and transfers it to the pty.  Returns true on success and undef on
  241. failure.  Note that this must be called upon the I<slave>, i.e.
  242.  
  243.  $pty->slave->clone_winsize_from(\*STDIN);
  244.  
  245. On some systems, the master pty also isatty.  I actually have no
  246. idea if setting terminal sizes there is passed through to the slave,
  247. so if this method is called for a master that is not a tty, it
  248. silently returns OK.
  249.  
  250. See the C<try> script for example code how to propagate SIGWINCH.
  251.  
  252. =back
  253.  
  254.  
  255. =head1 SEE ALSO
  256.  
  257. L<IO::Tty>, L<IO::Tty::Constant>, L<IO::Handle>, L<Expect>, L<Proc::SyncExec>
  258.  
  259.  
  260. =head1 MAILING LISTS
  261.  
  262. As this module is mainly used by Expect, support for it is available
  263. via the two Expect mailing lists, expectperl-announce and
  264. expectperl-discuss, at
  265.  
  266.   http://lists.sourceforge.net/lists/listinfo/expectperl-announce
  267.  
  268. and
  269.  
  270.   http://lists.sourceforge.net/lists/listinfo/expectperl-discuss
  271.  
  272.  
  273. =head1 AUTHORS
  274.  
  275. Originally by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>, based on the
  276. Ptty module by Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>.
  277.  
  278. Now maintained and heavily rewritten by Roland Giersig
  279. E<lt>F<RGiersig@cpan.org>E<gt>.
  280.  
  281. Contains copyrighted stuff from openssh v3.0p1, authored by 
  282. Tatu Ylonen <ylo@cs.hut.fi>, Markus Friedl and Todd C. Miller
  283. <Todd.Miller@courtesan.com>.
  284.  
  285.  
  286. =head1 COPYRIGHT
  287.  
  288. Now all code is free software; you can redistribute it and/or modify
  289. it under the same terms as Perl itself.
  290.  
  291. Nevertheless the above AUTHORS retain their copyrights to the various
  292. parts and want to receive credit if their source code is used.
  293. See the source for details.
  294.  
  295.  
  296. =head1 DISCLAIMER
  297.  
  298. THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
  299. WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  300. MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  301. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  302. INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  303. BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
  304. OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  305. ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
  306. TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
  307. USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
  308. DAMAGE.
  309.  
  310. In other words: Use at your own risk.  Provided as is.  Your mileage
  311. may vary.  Read the source, Luke!
  312.  
  313. And finally, just to be sure:
  314.  
  315. Any Use of This Product, in Any Manner Whatsoever, Will Increase the
  316. Amount of Disorder in the Universe. Although No Liability Is Implied
  317. Herein, the Consumer Is Warned That This Process Will Ultimately Lead
  318. to the Heat Death of the Universe.
  319.  
  320. =cut
  321.  
  322.